home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / RWDEMOS.ZIP / RWPDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  13.3 KB  |  431 lines
  1. {************************************************}
  2. {                                                }
  3. {   Resource Workshop Demo                       }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. {
  9.    This example can be compiled with either the "standard" windows look
  10.    or the "Borland look". By default, it uses "standard" windows
  11.    controls. To cause it to use Borland Windows Custom Controls, select
  12.    Options.Compiler and enter BWCC in the Conditional defines field.
  13. }
  14.  
  15.  
  16. program RWPDemo;
  17.  
  18. {$ifdef BWCC}
  19. {$R RWPDEMOB.RES}
  20. {$else}
  21. {$R RWPDEMO.RES}
  22. {$endif}
  23. {$D 'Resource Workshop Demo Program. Copyright (c) Borland 1992'}
  24.  
  25. uses WinTypes, WinProcs, Objects, OWindows, ODialogs,
  26. {$ifdef BWCC}
  27.   BWCC,
  28. {$endif}
  29.   Strings,  RWPDemoC, RWPDlgs, RWPWnd, WinDOS;
  30.  
  31. const
  32.   AppName = 'RWPDEMO';
  33.   StatusLineHeight        =  20;
  34.   TextStart               = 200; { Location for hints in status line }
  35.   EditFirst               = cm_EditUndo;
  36.   EnvironmentFirst        = cm_Preferences;
  37.   FileFirst               = cm_New;
  38.   Helpfirst               = cm_Index;
  39.   OptionFirst             = cm_Directories;
  40.   ViewFirst               = cm_All;
  41.   WindowFirst             = cm_TileChildren;
  42.   am_DrawStatusLine       = wm_User + 200;
  43.  
  44. type
  45.   PRWPApplication = ^RWPApplication;
  46.   RWPApplication = object(TApplication)
  47.     constructor Init(AName: PChar);
  48.     procedure InitMainWindow; virtual;
  49.     procedure Error(ErrorCode: Integer); virtual;
  50.   end;
  51.  
  52. type
  53.   PRWPWindow = ^TRWPWindow;
  54.   TRWPWindow = object(TMDIWindow)
  55.     BmpStatusBar: HBitmap;
  56.     BmpStatusLine: HBitmap;
  57.     CurrentID: Word;
  58.     CurrentPopup: HMenu;
  59.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  60.     destructor  Done; virtual;
  61.     procedure AboutRWP(var Msg: TMessage); virtual cm_First + cm_About_RWP;
  62.     procedure BlastStatusLine(PaintDC: HDC);
  63.     procedure ReconstructStatusLine;
  64.     procedure DefCommandProc(var Msg: TMessage); virtual;
  65.     procedure FileNew(var Msg: TMessage); virtual cm_First + cm_New;
  66.     procedure FileOpen(var Msg: TMessage); virtual cm_First + cm_Open;
  67.     procedure FilePrint(var Msg: TMessage); virtual cm_First + cm_Print;
  68.     function  GetClassName: PChar; virtual;
  69.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  70.     procedure OpenAFile(FileType: Integer; FileName: PChar);
  71.     procedure OptionsDirectories(var Msg: TMessage); virtual cm_First+cm_Directories;
  72.     procedure OptionsMouse(var Msg: TMessage); virtual cm_First+cm_Mouse;
  73.     procedure OptionsOpen(var Msg: TMessage); virtual cm_First+cm_Options_Open;
  74.     procedure OptionsPreferences(var Msg: TMessage); virtual cm_First+cm_Preferences;
  75.     procedure OptionsSave(var Msg: TMessage); virtual cm_First+cm_Options_Save;
  76.     procedure OptionsSaveAs(var Msg: TMessage); virtual cm_First+cm_Options_Saveas;
  77.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  78.     procedure StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  79.     procedure WMDrawStatusLine(var Msg: TMessage); virtual wm_First + am_DrawStatusLine;
  80.     procedure WMMenuSelect(var Msg: TMessage); virtual wm_First + wm_MenuSelect;
  81.     procedure WMEnterIdle(var Msg: TMessage); virtual wm_First + wm_EnterIdle;
  82.     procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  83.   end;
  84.  
  85. {------------------------- TRWPApplication implementation ---------------}
  86.  
  87. constructor RWPApplication.Init(AName: PChar);
  88. begin
  89.   TApplication.Init(AName);
  90.   HAccTable := LoadAccelerators(HInstance, MakeIntResource(Acc_Main));
  91. end;
  92.  
  93.  
  94. procedure RWPApplication.InitMainWindow;
  95. begin
  96.   MainWindow := New(PRWPWindow, Init(nil, 'Resource Workshop Demo Program'));
  97. end;
  98.  
  99. procedure RWPApplication.Error(ErrorCode: Integer);
  100. var
  101.   Title: array [0..40] of char;
  102.   Msg: array [0..80] of char;
  103. begin
  104.   if (ErrorCode > 0) and
  105.      (LoadString(HInstance, ErrorCode, Msg, SizeOf(Msg)) > 0) and
  106.      (LoadString(HInstance, ErrorCode+1, Title, SizeOf(Title)) > 0) then
  107.     MessageBox(0, Msg, Title, mb_IconExclamation or mb_OK)
  108.   else
  109.     TApplication.Error(ErrorCode);
  110. end;
  111.  
  112.  
  113. {--------------------------- TRWPWindow implementation ------------------}
  114.  
  115. constructor TRWPWindow.Init(AParent:PWIndowsObject; ATitle:PChar);
  116. begin
  117.   TMDIWindow.Init('RWP Application', LoadMenu(HInstance,
  118.     MakeIntResource(men_Main)));
  119.   BmpStatusBar := LoadBitmap(HInstance, MakeIntResource(bmp_StatusBar));
  120.   BmpStatusLine := 0;
  121. end;
  122.  
  123. procedure TRWPWindow.AboutRWP(var Msg:TMessage);
  124. begin
  125.   Application^.ExecDialog(New(PRWPDialog, Init(@Self, MakeIntResource(dlg_About))));
  126. end;
  127.  
  128. procedure TRWPWindow.BlastStatusLine(PaintDC: HDC);
  129. var
  130.   ClientRect: TRect;
  131.   MemDC: HDC;
  132.   OldBmp: THandle;
  133. begin
  134.   GetClientRect(HWindow, ClientRect);
  135.   MemDC := CreateCompatibleDC(PaintDC);
  136.   OldBmp := SelectObject(MemDC, BmpStatusLine);
  137.   with ClientRect do
  138.     BitBlt(PaintDC, 0, Bottom - StatusLineHeight, ClientRect.Right,
  139.       StatusLineHeight, MemDC, 0, 0, SrcCopy);
  140.   SelectObject(MemDC, OldBmp);
  141.   DeleteDC(MemDC);
  142. end;
  143.  
  144. procedure TRWPWindow.DefCommandProc(var Msg: TMessage);
  145. var
  146.   DC: HDC;
  147. begin
  148.   TMDIWindow.DefCommandProc(Msg);
  149.   if CurrentPopup <> 0 then
  150.   begin
  151.     CurrentPopup := 0;
  152.     CurrentID := 0;
  153.     DC := GetDC(HWindow);
  154.     BlastStatusLine(DC);
  155.     ReleaseDC(HWindow, DC);
  156.   end;
  157. end;
  158.  
  159. destructor TRWPWindow.Done;
  160. begin
  161.   DeleteObject(BmpStatusLine);
  162.   DeleteObject(BmpStatusBar);
  163.   TMDIWindow.Done;
  164. end;
  165.  
  166. procedure TRWPWindow.FileNew(var Msg:TMessage);
  167. var
  168.   FileType: Integer;
  169. begin
  170.   if Application^.ExecDialog(New(PFileNew,
  171.     Init(@Self, FileType))) = id_OK then OpenAFile(FileType, nil)
  172. end;
  173.  
  174. procedure TRWPWindow.FileOpen(var Msg:TMessage);
  175. var
  176.   FileName: array[0..128] of Char;
  177.   FileType: Integer;
  178. begin
  179.   FillChar(Filename, sizeof(FileName), #0);
  180.   StrCopy(Filename, '*.txt');
  181.   FileType := FileWindow;
  182.   if Application^.ExecDialog(New(PFileOpen,
  183.     Init(@Self, FileType, FileName))) = id_OK then
  184.     OpenAFile(FileType,FileName)
  185. end;
  186.  
  187. procedure TRWPWindow.FilePrint(var Msg:TMessage);
  188. begin
  189.   StubDialog(New(PRWPDialog, Init(@Self,MakeIntResource(dlg_Print))),'Print');
  190. end;
  191.  
  192. function TRWPWindow.GetClassName: PChar;
  193. begin
  194.   GetClassName := 'RWPWindow';
  195. end;
  196.  
  197. procedure TRWPWindow.GetWindowClass(var WndClass: TWndClass);
  198. begin
  199.   TMDIWindow.GetWindowClass(WndClass);
  200.   WndClass.HIcon := LoadIcon(HInstance, MakeIntResource(ico_RWPDemo));
  201.   WndClass.HBrBackground := color_AppWorkspace + 1;
  202. end;
  203.  
  204. procedure TRWPWindow.OpenAFile(FileType: Integer; FileName: PChar);
  205. begin
  206.   with PRWPApplication(Application)^ do
  207.     case FileType of
  208.       ScribbleWindow:
  209.         MakeWindow(new(PScribbleWindow, Init(@Self, FileName)));
  210.       FileWindow:
  211.         MakeWindow(new(PEditWindow, Init(@Self, FileName)));
  212.       GraphWindow:
  213.         MakeWindow(new(PGraphWindow, Init(@Self, FileName)));
  214.     end;
  215. end;
  216.  
  217. procedure TRWPWindow.OptionsDirectories(var Msg:TMessage);
  218. begin
  219.   StubDialog(new(PDlgDirectories,
  220.     Init(@Self, MakeIntResource(dlg_Options_Directories))), 'Directories');
  221. end;
  222.  
  223. procedure TRWPWindow.OptionsMouse(var Msg:TMessage);
  224. begin
  225.   StubDialog(new(PRWPDialog,
  226.     Init(@Self, MakeIntResource(dlg_MouseDialog))), 'Mouse');
  227. end;
  228.  
  229. procedure TRWPWindow.OptionsOpen(var Msg:TMessage);
  230. begin
  231.   StubDialog(new(PRWPDialog,
  232.     Init(@Self, MakeIntResource(dlg_Options_Open))), 'Options Open');
  233. end;
  234.  
  235. procedure TRWPWindow.OptionsPreferences(var Msg:TMessage);
  236. begin
  237.   StubDialog(new(PRWPDialog,
  238.     Init(@Self, MakeIntResource(dlg_Preferences))), 'Preferences');
  239. end;
  240.  
  241. procedure TRWPWindow.OptionsSave(Var Msg: TMessage);
  242. begin
  243.   MessageBox(HWindow, 'Feature not implemented', 'Options Save', mb_OK);
  244. end;
  245.  
  246. procedure TRWPWindow.OptionsSaveAs(var Msg:TMessage);
  247. begin
  248.   StubDialog(new(PRWPDialog,
  249.     Init(@Self,MakeIntResource(dlg_Options_SaveAs))), 'Options SaveAs');
  250. end;
  251.  
  252. procedure TRWPWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  253. begin
  254.   TMDIWindow.Paint(PaintDC, PaintInfo);
  255.   BlastStatusLine(PaintDC);
  256. end;
  257.  
  258. procedure TRWPWindow.StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  259. begin
  260.   if Application^.ExecDialog(ADialog) = id_Ok then
  261.     MessageBox(HWindow, 'Feature not implemented', ACaption, mb_OK);
  262. end;
  263.  
  264. procedure TRWPWindow.WMDrawStatusLine(var Msg: TMessage);
  265. var
  266.   DC: HDC;
  267.   Rect: TRect;
  268.   Str: array[0..128] of Char;
  269.   StrID: Integer;
  270.   hOld: HFont;
  271.   TextHeight: Integer;
  272. begin
  273.   if CurrentID <> 0 then
  274.   begin
  275.     case CurrentID of
  276.       cm_New: StrID := sth_FileNew;
  277.       cm_Open: StrID := sth_FileOpen;
  278.       cm_Save: StrID := sth_FileSave;
  279.       cm_SaveAs: StrID := sth_FileSaveAs;
  280.       cm_Print: StrID := sth_FilePrint;
  281.       cm_Exit: StrID := sth_FileExit;
  282.       cm_EditUndo: StrID := sth_EditUndo;
  283.       cm_EditCut: StrID := sth_EditCut;
  284.       cm_EditCopy: StrID := sth_EditCopy;
  285.       cm_EditPaste: StrID := sth_EditPaste;
  286.       cm_EditDelete: StrID := sth_EditDelete;
  287.       cm_EditClear: StrID := sth_EditClear;
  288.       cm_Options_Open: StrID := sth_OptionsOpen;
  289.       cm_all: StrID := sth_ViewAll;
  290.       cm_By: StrID := sth_ViewBy;
  291.       cm_Some: StrID := sth_ViewSome;
  292.       cm_Directories: StrID := sth_OptionsDirectory;
  293.       cm_Options_Save: StrID := sth_OptionsSave;
  294.       cm_Options_SaveAs: StrID := sth_OptionsSaveAs;
  295.       cm_Preferences: StrID := sth_EnvironmentPreferences;
  296.       cm_Mouse: StrID := sth_EnvironmentMouse;
  297.       cm_TileChildren: StrID := sth_WindowTile;
  298.       cm_CascadeChildren: StrID := sth_WindowCascade;
  299.       cm_ArrangeIcons: StrID := sth_WindowArrange;
  300.       cm_CloseChildren: StrID := sth_WindowCloseAll;
  301.       cm_Index: StrID := sth_HelpIndex;
  302.       cm_Topic_Search: StrID := sth_HelpTopic;
  303.       cm_Glossary: StrID := sth_HelpGlossary;
  304.       cm_Using_Help: StrID := sth_HelpUsing;
  305.       cm_About_RWP: StrID := sth_HelpAbout;
  306.       else
  307.         Exit;
  308.     end
  309.   end
  310.   else
  311.   if CurrentPopup <> 0 then
  312.   begin
  313.     case GetMenuItemID(CurrentPopup, 0) of
  314.       FileFirst: StrID := sth_File;
  315.       EditFirst: StrID := sth_Edit;
  316.       ViewFirst: StrID := sth_View;
  317.       WindowFirst: StrID := sth_Window;
  318.       OptionFirst: StrID := sth_Option;
  319.       EnvironmentFirst: StrID := sth_OptionsEnvironment;
  320.       HelpFirst: StrID := sth_Help;
  321.       else
  322.         Exit;
  323.     end;
  324.   end;
  325.  
  326.   DC := GetDC(HWindow);
  327.   BlastStatusLine(DC);
  328.   if (CurrentPopup <> 0) or (CurrentID <> 0) then
  329.   begin
  330.     hOld := SelectObject(DC, GetStockObject(ANSI_VAR_FONT));
  331.     LoadString(HInstance, StrID, Str, Sizeof(Str));
  332.     GetClientRect(HWindow, Rect);
  333.     SetBKColor(DC, RGB(192, 192, 192));
  334.     TextHeight :=  HiWord( GetTextExtent( DC, Str, 1) );
  335.     TextOut(DC, TextStart+10,
  336.       Rect.bottom - StatusLineHeight + ( ( StatusLineHeight - TextHeight ) div 2),
  337.       Str, strlen(Str));
  338.     SelectObject(DC, hOld);
  339.   end;
  340.   ReleaseDC(HWindow, DC);
  341. end;
  342.  
  343. procedure TRWPWindow.WMMenuSelect(var Msg: TMessage);
  344. begin
  345.   if Msg.LParamLo = $FFFF then
  346.   begin
  347.     CurrentPopup := 0;
  348.     CurrentID := 0;
  349.   end
  350.   else
  351.   if (Msg.LParamLo and mf_Popup) <> 0 then
  352.   begin
  353.    CurrentPopup := Msg.WParam;
  354.     CurrentID := 0;
  355.   end
  356.   else
  357.     CurrentID := Msg.WParam;
  358.   PostMessage(HWindow,am_DrawStatusLine, 0, 0);
  359. end;
  360.  
  361. procedure TRWPWindow.WMEnterIdle(var Msg: TMessage);
  362. { If the user pressed the F1 key, and a Dialog box is active (and idle), send
  363.   an ID_Help message to the dialog, to get the behavior associated with
  364.   pressing the help button in that dialog }
  365. begin
  366.  if ( Msg.WParam = Msgf_DialogBox) and ( ( GetKeyState( Vk_F1) and $8000) <> 0) then
  367.    SendMessage( Msg.LParamLo, wm_Command, Id_Help, 0);
  368. end;
  369.  
  370. procedure TRWPWindow.WMSize(var Msg: TMessage);
  371. var
  372.   Rect: TRect;
  373. begin
  374.   TMDIWindow.WMSize(Msg);
  375.   GetClientRect(HWindow, Rect);
  376.   SetWindowPos(ClientWnd^.HWindow, 0, 0, 0, Rect.Right,
  377.     Rect.Bottom - StatusLineHeight, swp_NoZOrder);
  378.   ReconstructStatusLine;
  379. end;
  380.  
  381. procedure TRWPWindow.ReconstructStatusLine;
  382. var
  383.   Bmp: HBitmap;
  384.   DC: HDC;
  385.   DestDC: HDC;
  386.   OldSrc: HBitmap;
  387.   OldDest: HBitmap;
  388.   Rect: TRect;
  389.   SrcDC: HDC;
  390. begin
  391.   GetClientRect(HWindow, Rect);
  392.   DC := GetDC(HWindow);
  393.   SrcDC := CreateCompatibleDC(DC);
  394.   DestDC := CreateCompatibleDC(DC);
  395.   ReleaseDC(HWindow, DC);
  396.  
  397.   Bmp := LoadBitmap(HInstance, MakeIntResource(bmp_StatusLine));
  398.   OldSrc := SelectObject(SrcDC, Bmp);
  399.   if BmpStatusLine <> 0 then
  400.     DeleteObject(BmpStatusLine);
  401.   BmpStatusLine := CreateCompatibleBitmap(DC, Rect.Right, StatusLineHeight);
  402.   OldDest := SelectObject(DestDC, BmpStatusLine);
  403.   BitBlt(DestDC, 0, 0, 5, StatusLineHeight, SrcDC, 0, 0, srcCopy);
  404.   StretchBlt(DestDC, 5, 0, Rect.Right - 5, StatusLineHeight,
  405.              SrcDC, 6, 0, 20, StatusLineHeight, srcCopy);
  406.   BitBlt(DestDC, Rect.Right - 5, 0, 5, StatusLineHeight, SrcDC, 59, 0, srcCopy);
  407.  
  408.   SelectObject(SrcDC, BmpStatusBar);
  409.   BitBlt(DestDC, 40, 0, 10, StatusLineHeight,
  410.          SrcDC, 0, 0, SrcCopy);
  411.   BitBlt(DestDC, 100, 0, 10, StatusLineHeight,
  412.          SrcDC, 0, 0, SrcCopy);
  413.   BitBlt(DestDC, TextStart, 0, 10, StatusLineHeight,
  414.          SrcDC, 0, 0, SrcCopy);
  415.  
  416.   SelectObject(SrcDC, OldSrc);
  417.   BmpStatusLine := SelectObject(DestDC, OldDest);
  418.   DeleteDC(SrcDC);
  419.   DeleteDC(DestDC);
  420.   DeleteObject(Bmp);
  421. end;
  422.  
  423. var
  424.   RWPApp:RWPApplication;
  425.  
  426. begin
  427.   RWPApp.Init(AppName);
  428.   RWPApp.Run;
  429.   RWPApp.Done;
  430. end.
  431.